home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / r4rsyn < prev    next >
Text File  |  1992-11-07  |  17KB  |  544 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; This material was developed by the Scheme project at the
  6. ;;; Massachusetts Institute of Technology, Department of Electrical
  7. ;;; Engineering and Computer Science.  Permission to copy this
  8. ;;; software, to redistribute it, and to use it for any purpose is
  9. ;;; granted, subject to the following restrictions and understandings.
  10. ;;;
  11. ;;; 1. Any copy made of this software must include this copyright
  12. ;;; notice in full.
  13. ;;;
  14. ;;; 2. Users of this software agree to make their best efforts (a) to
  15. ;;; return to the MIT Scheme project any improvements or extensions
  16. ;;; that they make, so that these may be included in future releases;
  17. ;;; and (b) to inform MIT of noteworthy uses of this software.
  18. ;;;
  19. ;;; 3. All materials developed as a consequence of the use of this
  20. ;;; software shall duly acknowledge such use, in accordance with the
  21. ;;; usual standards of acknowledging credit in academic research.
  22. ;;;
  23. ;;; 4. MIT has made no warrantee or representation that the operation
  24. ;;; of this software will be error-free, and MIT is under no
  25. ;;; obligation to provide any services, by way of maintenance, update,
  26. ;;; or otherwise.
  27. ;;;
  28. ;;; 5. In conjunction with products arising from the use of this
  29. ;;; material, there shall be no use of the name of the Massachusetts
  30. ;;; Institute of Technology nor of any adaptation thereof in any
  31. ;;; advertising, promotional, or sales literature without prior
  32. ;;; written consent from MIT in each case.
  33.  
  34. ;;;; R4RS Syntax
  35.  
  36. (define scheme-syntactic-environment #f)
  37.  
  38. (define (initialize-scheme-syntactic-environment!)
  39.   (set! scheme-syntactic-environment
  40.     ((compose-macrologies
  41.       (make-core-primitive-macrology)
  42.       (make-binding-macrology syntactic-binding-theory
  43.                   'LET-SYNTAX 'LETREC-SYNTAX 'DEFINE-SYNTAX)
  44.       (make-binding-macrology variable-binding-theory
  45.                   'LET 'LETREC 'DEFINE)
  46.       (make-r4rs-primitive-macrology)
  47.       (make-core-expander-macrology)
  48.       (make-syntax-rules-macrology))
  49.      root-syntactic-environment)))
  50.  
  51. ;;;; Core Primitives
  52.  
  53. (define (make-core-primitive-macrology)
  54.   (make-primitive-macrology
  55.    (lambda (define-classifier define-compiler)
  56.  
  57.      (define-classifier 'BEGIN
  58.        (lambda (form environment definition-environment)
  59.      (syntax-check '(KEYWORD * FORM) form)
  60.      (make-body-item (classify/subforms (cdr form)
  61.                         environment
  62.                         definition-environment))))
  63.  
  64.      (define-compiler 'DELAY
  65.        (lambda (form environment)
  66.      (syntax-check '(KEYWORD EXPRESSION) form)
  67.      (output/delay
  68.       (compile/subexpression (cadr form)
  69.                  environment))))
  70.  
  71.      (define-compiler 'IF
  72.        (lambda (form environment)
  73.      (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION) form)
  74.      (output/conditional
  75.       (compile/subexpression (cadr form) environment)
  76.       (compile/subexpression (caddr form) environment)
  77.       (if (null? (cdddr form))
  78.           (output/unspecific)
  79.           (compile/subexpression (cadddr form)
  80.                      environment)))))
  81.  
  82.      (define-compiler 'QUOTE
  83.        (lambda (form environment)
  84.      environment            ;ignore
  85.      (syntax-check '(KEYWORD DATUM) form)
  86.      (output/literal-quoted (strip-syntactic-closures (cadr form))))))))
  87.  
  88. ;;;; Bindings
  89.  
  90. (define (make-binding-macrology binding-theory
  91.                 let-keyword letrec-keyword define-keyword)
  92.   (make-primitive-macrology
  93.    (lambda (define-classifier define-compiler)
  94.  
  95.      (let ((pattern/let-like
  96.         '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM))
  97.        (compile/let-like
  98.         (lambda (form environment body-environment output/let)
  99.           ;; Force evaluation order.
  100.           (let ((bindings
  101.              (let loop
  102.              ((bindings
  103.                (map (lambda (binding)
  104.                   (cons (car binding)
  105.                     (classify/subexpression
  106.                      (cadr binding)
  107.                      environment)))
  108.                 (cadr form))))
  109.                (if (null? bindings)
  110.                '()
  111.                (let ((binding
  112.                   (binding-theory body-environment
  113.                           (caar bindings)
  114.                           (cdar bindings))))
  115.                  (if binding
  116.                  (cons binding (loop (cdr bindings)))
  117.                  (loop (cdr bindings))))))))
  118.         (output/let (map car bindings)
  119.                 (map (lambda (binding)
  120.                    (compile-item/expression (cdr binding)))
  121.                  bindings)
  122.                 (compile-item/expression
  123.                  (classify/body (cddr form)
  124.                         body-environment)))))))
  125.  
  126.        (define-compiler let-keyword
  127.      (lambda (form environment)
  128.        (syntax-check pattern/let-like form)
  129.        (compile/let-like form
  130.                  environment
  131.                  (internal-syntactic-environment environment)
  132.                  output/let)))
  133.  
  134.        (define-compiler letrec-keyword
  135.      (lambda (form environment)
  136.        (syntax-check pattern/let-like form)
  137.        (let ((environment (internal-syntactic-environment environment)))
  138.          (reserve-names! (map car (cadr form)) environment)
  139.          (compile/let-like form
  140.                    environment
  141.                    environment
  142.                    output/letrec)))))
  143.  
  144.      (define-classifier define-keyword
  145.        (lambda (form environment definition-environment)
  146.      (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form)
  147.      (syntactic-environment/define! definition-environment
  148.                     (cadr form)
  149.                     (make-reserved-name-item))
  150.      (make-definition-item binding-theory
  151.                    (cadr form)
  152.                    (make-promise
  153.                 (lambda ()
  154.                   (classify/subexpression
  155.                    (caddr form)
  156.                    environment)))))))))
  157.  
  158. ;;;; Bodies
  159.  
  160. (define (classify/body forms environment)
  161.   (let ((environment (internal-syntactic-environment environment)))
  162.     (let forms-loop
  163.     ((forms forms)
  164.      (bindings '()))
  165.       (if (null? forms)
  166.       (syntax-error "no expressions in body"
  167.             "")
  168.       (let items-loop
  169.           ((items
  170.         (item->list
  171.          (classify/subform (car forms)
  172.                    environment
  173.                    environment)))
  174.            (bindings bindings))
  175.         (cond ((null? items)
  176.            (forms-loop (cdr forms)
  177.                    bindings))
  178.           ((definition-item? (car items))
  179.            (items-loop (cdr items)
  180.                    (let ((binding
  181.                       (bind-definition-item! environment
  182.                                  (car items))))
  183.                  (if binding
  184.                      (cons binding bindings)
  185.                      bindings))))
  186.           (else
  187.            (let ((body
  188.               (make-body-item
  189.                (append items
  190.                    (flatten-body-items
  191.                     (classify/subforms
  192.                      (cdr forms)
  193.                      environment
  194.                      environment))))))
  195.              (make-expression-item
  196.               (lambda ()
  197.             (output/letrec
  198.              (map car bindings)
  199.              (map (lambda (binding)
  200.                 (compile-item/expression (cdr binding)))
  201.                   bindings)
  202.              (compile-item/expression body))) forms)))))))))
  203.  
  204. ;;;; R4RS Primitives
  205.  
  206. (define (make-r4rs-primitive-macrology)
  207.   (make-primitive-macrology
  208.    (lambda (define-classifier define-compiler)
  209.  
  210.      (define (transformer-keyword expander->classifier)
  211.        (lambda (form environment definition-environment)
  212.      definition-environment        ;ignore
  213.      (syntax-check '(KEYWORD EXPRESSION) form)
  214.      (let ((item
  215.         (classify/subexpression (cadr form)
  216.                     scheme-syntactic-environment)))
  217.        (let ((transformer (base:eval (compile-item/expression item))))
  218.          (if (procedure? transformer)
  219.          (make-keyword-item
  220.           (expander->classifier transformer environment) item)
  221.          (syntax-error "transformer not a procedure"
  222.                    transformer))))))
  223.  
  224.      (define-classifier 'TRANSFORMER
  225.        ;; "Syntactic Closures" transformer
  226.        (transformer-keyword sc-expander->classifier))
  227.  
  228.      (define-classifier 'ER-TRANSFORMER
  229.        ;; "Explicit Renaming" transformer
  230.        (transformer-keyword er-expander->classifier))
  231.  
  232.      (define-compiler 'LAMBDA
  233.        (lambda (form environment)
  234.      (syntax-check '(KEYWORD R4RS-BVL + FORM) form)
  235.      (let ((environment (internal-syntactic-environment environment)))
  236.        ;; Force order -- bind names before classifying body.
  237.        (let ((bvl-description
  238.           (let ((rename
  239.              (lambda (identifier)
  240.                (bind-variable! environment identifier))))
  241.             (let loop ((bvl (cadr form)))
  242.               (cond ((null? bvl)
  243.                  '())
  244.                 ((pair? bvl)
  245.                  (cons (rename (car bvl)) (loop (cdr bvl))))
  246.                 (else
  247.                  (rename bvl)))))))
  248.          (output/lambda bvl-description
  249.                 (compile-item/expression
  250.                  (classify/body (cddr form)
  251.                         environment)))))))
  252.  
  253.      (define-compiler 'SET!
  254.        (lambda (form environment)
  255.      (syntax-check '(KEYWORD FORM EXPRESSION) form)
  256.      (output/assignment
  257.       (let loop
  258.           ((form (cadr form))
  259.            (environment environment))
  260.         (cond ((identifier? form)
  261.            (let ((item
  262.               (syntactic-environment/lookup environment form)))
  263.              (if (variable-item? item)
  264.              (variable-item/name item)
  265.              (slib:error "target of assignment not a variable"
  266.                        form))))
  267.           ((syntactic-closure? form)
  268.            (let ((form (syntactic-closure/form form))
  269.              (environment
  270.               (filter-syntactic-environment
  271.                (syntactic-closure/free-names form)
  272.                environment
  273.                (syntactic-closure/environment form))))
  274.              (loop form
  275.                environment)))
  276.           (else
  277.            (slib:error "target of assignment not an identifier"
  278.                  form))))
  279.       (compile/subexpression (caddr form)
  280.                  environment))))
  281.  
  282.      ;; end MAKE-R4RS-PRIMITIVE-MACROLOGY
  283.      )))
  284.  
  285. ;;;; Core Expanders
  286.  
  287. (define (make-core-expander-macrology)
  288.   (make-er-expander-macrology
  289.    (lambda (define-expander base-environment)
  290.  
  291.      (let ((keyword (make-syntactic-closure base-environment '() 'DEFINE)))
  292.        (define-expander 'DEFINE
  293.      (lambda (form rename compare)
  294.        compare            ;ignore
  295.        (if (syntax-match? '((IDENTIFIER . R4RS-BVL) + FORM) (cdr form))
  296.            `(,keyword ,(caadr form)
  297.               (,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form)))
  298.            `(,keyword ,@(cdr form))))))
  299.  
  300.      (let ((keyword (make-syntactic-closure base-environment '() 'LET)))
  301.        (define-expander 'LET
  302.      (lambda (form rename compare)
  303.        compare            ;ignore
  304.        (if (syntax-match? '(IDENTIFIER (* (IDENTIFIER EXPRESSION)) + FORM)
  305.                   (cdr form))
  306.            (let ((name (cadr form))
  307.              (bindings (caddr form)))
  308.          `((,(rename 'LETREC)
  309.             ((,name (,(rename 'LAMBDA) ,(map car bindings) ,@(cdddr form))))
  310.             ,name)
  311.            ,@(map cadr bindings)))
  312.            `(,keyword ,@(cdr form))))))
  313.  
  314.      (define-expander 'LET*
  315.        (lambda (form rename compare)
  316.      compare            ;ignore
  317.      (if (syntax-match? '((* (IDENTIFIER EXPRESSION)) + FORM) (cdr form))
  318.          (let ((bindings (cadr form))
  319.            (body (cddr form))
  320.            (keyword (rename 'LET)))
  321.            (if (null? bindings)
  322.            `(,keyword ,bindings ,@body)
  323.            (let loop ((bindings bindings))
  324.              (if (null? (cdr bindings))
  325.              `(,keyword ,bindings ,@body)
  326.              `(,keyword (,(car bindings))
  327.                     ,(loop (cdr bindings)))))))
  328.          (ill-formed-syntax form))))
  329.  
  330.      (define-expander 'AND
  331.        (lambda (form rename compare)
  332.      compare            ;ignore
  333.      (if (syntax-match? '(* EXPRESSION) (cdr form))
  334.          (let ((operands (cdr form)))
  335.            (if (null? operands)
  336.            `#T
  337.            (let ((if-keyword (rename 'IF)))
  338.              (let loop ((operands operands))
  339.                (if (null? (cdr operands))
  340.                (car operands)
  341.                `(,if-keyword ,(car operands)
  342.                      ,(loop (cdr operands))
  343.                      #F))))))
  344.          (ill-formed-syntax form))))
  345.  
  346.      (define-expander 'OR
  347.        (lambda (form rename compare)
  348.      compare            ;ignore
  349.      (if (syntax-match? '(* EXPRESSION) (cdr form))
  350.          (let ((operands (cdr form)))
  351.            (if (null? operands)
  352.            `#F
  353.            (let ((let-keyword (rename 'LET))
  354.              (if-keyword (rename 'IF))
  355.              (temp (rename 'TEMP)))
  356.              (let loop ((operands operands))
  357.                (if (null? (cdr operands))
  358.                (car operands)
  359.                `(,let-keyword ((,temp ,(car operands)))
  360.                       (,if-keyword ,temp
  361.                                ,temp
  362.                                ,(loop (cdr operands)))))))))
  363.          (ill-formed-syntax form))))
  364.  
  365.      (define-expander 'CASE
  366.        (lambda (form rename compare)
  367.      (if (syntax-match? '(EXPRESSION + (DATUM + EXPRESSION)) (cdr form))
  368.          (letrec
  369.          ((process-clause
  370.            (lambda (clause rest)
  371.              (cond ((null? (car clause))
  372.                 (process-rest rest))
  373.                ((and (identifier? (car clause))
  374.                  (compare (rename 'ELSE) (car clause))
  375.                  (null? rest))
  376.                 `(,(rename 'BEGIN) ,@(cdr clause)))
  377.                ((list? (car clause))
  378.                 `(,(rename 'IF) (,(rename 'MEMV) ,(rename 'TEMP)
  379.                                  ',(car clause))
  380.                         (,(rename 'BEGIN) ,@(cdr clause))
  381.                         ,(process-rest rest)))
  382.                (else
  383.                 (syntax-error "ill-formed clause" clause)))))
  384.           (process-rest
  385.            (lambda (rest)
  386.              (if (null? rest)
  387.              (unspecific-expression)
  388.              (process-clause (car rest) (cdr rest))))))
  389.            `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form)))
  390.                 ,(process-clause (caddr form) (cdddr form))))
  391.          (ill-formed-syntax form))))
  392.  
  393.      (define-expander 'COND
  394.        (lambda (form rename compare)
  395.      (letrec
  396.          ((process-clause
  397.            (lambda (clause rest)
  398.          (cond
  399.           ((or (not (list? clause))
  400.                (null? clause))
  401.            (syntax-error "ill-formed clause" clause))
  402.           ((and (identifier? (car clause))
  403.             (compare (rename 'ELSE) (car clause)))
  404.            (cond
  405.             ((or (null? (cdr clause))
  406.              (and (identifier? (cadr clause))
  407.                   (compare (rename '=>) (cadr clause))))
  408.              (syntax-error "ill-formed ELSE clause" clause))
  409.             ((not (null? rest))
  410.              (syntax-error "misplaced ELSE clause" clause))
  411.             (else
  412.              `(,(rename 'BEGIN) ,@(cdr clause)))))
  413.           ((null? (cdr clause))
  414.            `(,(rename 'OR) ,(car clause) ,(process-rest rest)))
  415.           ((and (identifier? (cadr clause))
  416.             (compare (rename '=>) (cadr clause)))
  417.            (if (and (pair? (cddr clause))
  418.                 (null? (cdddr clause)))
  419.                `(,(rename 'LET)
  420.              ((,(rename 'TEMP) ,(car clause)))
  421.              (,(rename 'IF) ,(rename 'TEMP)
  422.                     (,(caddr clause) ,(rename 'TEMP))
  423.                     ,(process-rest rest)))
  424.                (syntax-error "ill-formed => clause" clause)))
  425.           (else
  426.            `(,(rename 'IF) ,(car clause)
  427.                    (,(rename 'BEGIN) ,@(cdr clause))
  428.                    ,(process-rest rest))))))
  429.           (process-rest
  430.            (lambda (rest)
  431.          (if (null? rest)
  432.              (unspecific-expression)
  433.              (process-clause (car rest) (cdr rest))))))
  434.        (let ((clauses (cdr form)))
  435.          (if (null? clauses)
  436.          (syntax-error "no clauses" form)
  437.          (process-clause (car clauses) (cdr clauses)))))))
  438.  
  439.      (define-expander 'DO
  440.        (lambda (form rename compare)
  441.      compare            ;ignore
  442.      (if (syntax-match? '((* (IDENTIFIER EXPRESSION ? EXPRESSION))
  443.                   (+ EXPRESSION)
  444.                   * FORM)
  445.                 (cdr form))
  446.          (let ((bindings (cadr form)))
  447.            `(,(rename 'LETREC)
  448.          ((,(rename 'DO-LOOP)
  449.            (,(rename 'LAMBDA)
  450.             ,(map car bindings)
  451.             (,(rename 'IF) ,(caaddr form)
  452.                    ,(if (null? (cdaddr form))
  453.                     (unspecific-expression)
  454.                     `(,(rename 'BEGIN) ,@(cdaddr form)))
  455.                    (,(rename 'BEGIN)
  456.                     ,@(cdddr form)
  457.                     (,(rename 'DO-LOOP)
  458.                      ,@(map (lambda (binding)
  459.                           (if (null? (cddr binding))
  460.                           (car binding)
  461.                           (caddr binding)))
  462.                         bindings)))))))
  463.          (,(rename 'DO-LOOP) ,@(map cadr bindings))))
  464.          (ill-formed-syntax form))))
  465.  
  466.      (define-expander 'QUASIQUOTE
  467.        (lambda (form rename compare)
  468.      (define (descend-quasiquote x level return)
  469.        (cond ((pair? x) (descend-quasiquote-pair x level return))
  470.          ((vector? x) (descend-quasiquote-vector x level return))
  471.          (else (return 'QUOTE x))))
  472.      (define (descend-quasiquote-pair x level return)
  473.        (cond ((not (and (pair? x)
  474.                 (identifier? (car x))
  475.                 (pair? (cdr x))
  476.                 (null? (cddr x))))
  477.           (descend-quasiquote-pair* x level return))
  478.          ((compare (rename 'QUASIQUOTE) (car x))
  479.           (descend-quasiquote-pair* x (+ level 1) return))
  480.          ((compare (rename 'UNQUOTE) (car x))
  481.           (if (zero? level)
  482.               (return 'UNQUOTE (cadr x))
  483.               (descend-quasiquote-pair* x (- level 1) return)))
  484.          ((compare (rename 'UNQUOTE-SPLICING) (car x))
  485.           (if (zero? level)
  486.               (return 'UNQUOTE-SPLICING (cadr x))
  487.               (descend-quasiquote-pair* x (- level 1) return)))
  488.          (else
  489.           (descend-quasiquote-pair* x level return))))
  490.      (define (descend-quasiquote-pair* x level return)
  491.        (descend-quasiquote
  492.         (car x) level
  493.         (lambda (car-mode car-arg)
  494.           (descend-quasiquote
  495.            (cdr x) level
  496.            (lambda (cdr-mode cdr-arg)
  497.          (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE))
  498.             (return 'QUOTE x))
  499.                ((eq? car-mode 'UNQUOTE-SPLICING)
  500.             (if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg))
  501.                 (return 'UNQUOTE car-arg)
  502.                 (return 'APPEND
  503.                     (list car-arg
  504.                       (finalize-quasiquote cdr-mode
  505.                                    cdr-arg)))))
  506.                ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg))
  507.             (return 'LIST
  508.                 (cons (finalize-quasiquote car-mode car-arg)
  509.                       (map (lambda (element)
  510.                          (finalize-quasiquote 'QUOTE
  511.                                   element))
  512.                        cdr-arg))))
  513.                ((eq? cdr-mode 'LIST)
  514.             (return 'LIST
  515.                 (cons (finalize-quasiquote car-mode car-arg)
  516.                       cdr-arg)))
  517.                (else
  518.             (return
  519.              'CONS
  520.              (list (finalize-quasiquote car-mode car-arg)
  521.                    (finalize-quasiquote cdr-mode cdr-arg))))))))))
  522.      (define (descend-quasiquote-vector x level return)
  523.        (descend-quasiquote
  524.         (vector->list x) level
  525.         (lambda (mode arg)
  526.           (case mode
  527.         ((QUOTE) (return 'QUOTE x))
  528.         ((LIST) (return 'VECTOR arg))
  529.         (else
  530.          (return 'LIST->VECTOR
  531.              (list (finalize-quasiquote mode arg))))))))
  532.      (define (finalize-quasiquote mode arg)
  533.        (case mode
  534.          ((QUOTE) `(,(rename 'QUOTE) ,arg))
  535.          ((UNQUOTE) arg)
  536.          ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context" arg))
  537.          (else `(,(rename mode) ,@arg))))
  538.      (if (syntax-match? '(EXPRESSION) (cdr form))
  539.          (descend-quasiquote (cadr form) 0 finalize-quasiquote)
  540.          (ill-formed-syntax form))))
  541.  
  542. ;;; end MAKE-CORE-EXPANDER-MACROLOGY
  543.      )))
  544.